;;;
;;;      (<Move> ::= F<digit>|S<digit>|<digit><digit>
;;;	<digit> ::= 1|2|3|4.  The first case is a move from
;;; the hand to a final pile, the second from the hand
;;; to a storage pile  and the third a
;;; move from a storage pile to a final pile.

(DEFUN PLAY NIL 
       (PROG NIL 
	LOOP (OBVIOUSLY)
	     (IFF (OR (NOT AUTO) (NULL OBVIOUSES)) (GO AA))
	     (SETQ AUTOCOUNT (ADD1 AUTOCOUNT))
	     (SETQ ZZ (CAR OBVIOUSES))
	     (PRINT (LIST 'DOING ZZ))
	     (GO BB)
	AA   (SETQ Z (READ))
	     (IFF (EQ Z 'END) (RETURN NIL))
	     (IFF (EQ Z 'AUTO) (PROGN (SETQ AUTO T) (GO LOOP)))
	     (IFF (EQ Z 'MANUAL)
		  (PROGN (SETQ AUTO NIL) (GO LOOP)))
	     (IFF (EQ Z 'CANCEL) (GO JJ))
	     (IFF (NOT (OKSYNTAX Z)) (GO MM))
	     (SETQ ZZ (OPPEN Z))
	     (IFF (NOT (LEGAL1 ZZ)) (GO MM))
	BB   (SETQ MOVELIST (CONS ZZ MOVELIST))
	     (IFF (NOT (NUMBERP (CAR ZZ))) (GO HH))
	     (STORE (FINAL (CADR ZZ)) (CAR (STORAGE (CAR ZZ))))
	     (STORE (STORAGE (CAR ZZ)) (CDR (STORAGE (CAR ZZ))))
	     (DISPLAY)
	     (IFF (AND (EQUAL (FINAL 1.) 13.)
		       (EQUAL (FINAL 2.) 13.)
		       (EQUAL (FINAL 3.) 13.)
		       (EQUAL (FINAL 4.) 13.))
		  (PRINC (LIST 'AUTOCOUNT
			       (ASCII 61.)
			       AUTOCOUNT
			       (ASCII 44.)
			       'NMOVES
			       (ASCII 61.)
			       (LENGTH MOVELIST)))
		  (RETURN 'YOU_WIN))
	     (GO LOOP)
	HH   (IF (EQ (CAR ZZ) 'S)
		 (STORE (STORAGE (CADR ZZ))
			(CONS (CAR HAND) (STORAGE (CADR ZZ))))
		 (STORE (FINAL (CADR ZZ)) (CAR HAND)))
	     (SETQ HAND (CDR HAND))
	     (DISPLAY)
	     (GO LOOP)
	JJ   (IFF (NULL MOVELIST)
		  (PROGN (PRINT 'AT_BEGINNING)
			 (DISPLAY)
			 (GO LOOP)))
	     (SETQ ZZ (CAR MOVELIST))
	     (SETQ MOVELIST (CDR MOVELIST))
	     (IFF (NUMBERP (CAR ZZ)) (GO KK))
	     (SETQ HAND (CONS (IF (EQ (CAR ZZ) 'F)
				  (FINAL (CADR ZZ))
				  (CAR (STORAGE (CADR ZZ))))
			      HAND))
	     (IF (EQ (CAR ZZ) 'F)
		 (STORE (FINAL (CADR ZZ))
			(REMAINDER (- (FINAL (CADR ZZ)) (CADR ZZ))
				   13.))
		 (STORE (STORAGE (CADR ZZ))
			(CDR (STORAGE (CADR ZZ)))))
	     (DISPLAY)
	     (GO LOOP)
	KK   (STORE (STORAGE (CAR ZZ))
		    (CONS (FINAL (CADR ZZ)) (STORAGE (CAR ZZ))))
	     (STORE (FINAL (CADR ZZ))
		    (REMAINDER (- (PLUS 13. (FINAL (CADR ZZ)))
				  (CADR ZZ))
			       13.))
	     (DISPLAY)
	     (GO LOOP)
	MM   (PRINT 'NOT_LEGAL)
	     (GO LOOP))) 
(SETQ DECK '(4. 8.
		3.
		8.
		7.
		13.
		10.
		12.
		6.
		5.
		1.
		9.
		7.
		1.
		4.
		8.
		5.
		2.
		13.
		11.
		5.
		6.
		4.
		3.
		7.
		5.
		2.
		1.
		12.
		2.
		13.
		4.
		11.
		11.
		13.
		9.
		6.
		3.
		12.
		6.
		11.
		2.
		8.
		10.
		1.
		3.
		12.
		7.
		9.
		10.
		9.
		10.)) 
(DEFUN INIT NIL 
       (PROG NIL 
	     (SETQ AUTO T)
	     (SETQ AUTOCOUNT 0.)
	     (SETQ HAND DECK)
	     (SETQ MOVELIST NIL)
	     (ARRAY STORAGE T 5.)
	     (ARRAY FINAL T 5.)
	     (DO ((N 1. (ADD1 N))) ((> N 4.)) (STORE (FINAL N) 0.))
	     (SETQ Z NIL)
	     (DISPLAY)
	     (RETURN 'INIT))) 

(DEFUN DISPLAY NIL 
       (PROG NIL 
	     (PRINT (CONS 'FINALS
			  (DO ((M 1. (ADD1 M))
			       (U NIL (CONS (FINAL (- 5. M)) U)))
			      ((> M 4.) U))))
	     (PRINT (CONS 'S1 (STORAGE 1.)))
	     (PRINT (CONS 'S2 (STORAGE 2.)))
	     (PRINT (CONS 'S3 (STORAGE 3.)))
	     (PRINT (CONS 'S4 (STORAGE 4.)))
	     (PRINT (IF (NULL HAND)
			'HAND_EMPTY
			(LIST 'HAND (CAR HAND) (LENGTH HAND))))
	     (RETURN NIL))) 

(DEFUN SUCCEEDS (M N P) 
       (AND (NOT (EQUAL M 13.))
	    (EQUAL (REMAINDER N 13.) (REMAINDER (PLUS M P) 13.)))) 

(DEFUN ISDIG (N) 
       (OR (EQUAL N 1.) (EQUAL N 2.) (EQUAL N 3.) (EQUAL N 4.))) 

(DEFUN OKSYNTAX (MOVE) 
       ((LAMBDA (U) (AND (EQUAL (LENGTH U) 2.)
			 (ISDIG (CADR U))
			 (OR (ISDIG (CAR U))
			     (EQ (CAR U) 'S)
			     (EQ (CAR U) 'F))))
	(IF (NUMBERP MOVE)
	    (LIST (QUOTIENT MOVE 10.) (REMAINDER MOVE 10.))
	    (OPPEN MOVE)))) 

(DEFUN LEGAL (MOVE) (AND (OKSYNTAX MOVE) (LEGAL1 (OPPEN MOVE)))) 

(DEFUN LEGAL1 (M1) 
       (OR (AND (EQ (CAR M1) 'S) (NOT (NULL HAND)))
	   (AND (IF (EQ (CAR M1) 'F)
		    (NOT (NULL HAND))
		    (NOT (NULL (STORAGE (CAR M1)))))
		(SUCCEEDS (FINAL (CADR M1))
			  (IF (NUMBERP (CAR M1))
			      (CAR (STORAGE (CAR M1)))
			      (CAR HAND))
			  (CADR M1))))) 
(DEFUN OPPEN (MOVE) 
       (IF (NUMBERP MOVE)
	   (LIST (QUOTIENT MOVE 10.) (REMAINDER MOVE 10.))
	   ((LAMBDA (W) 
		    (IF (NOT (EQUAL (LENGTH W) 2.))
			NIL
			(LIST (COND ((EQUAL (CAR W) 83.) 'S)
				    ((EQUAL (CAR W) 70.) 'F)
				    (T NIL))
			      (- (CADR W) 48.))))
	    (EXPLODEN MOVE)))) 

(DEFUN SHUFFLE NIL 
       (PROG NIL 
	     (SETQ AUTO T)
	     (SETQ AUTOCOUNT 0.)
	     (SETQ DECK (SHUFFLE1 DECK))
	     (SETQ HAND DECK)
	     (SETQ MOVELIST NIL)
	     (ARRAY STORAGE T 5.)
	     (ARRAY FINAL T 5.)
	     (STORE (FINAL 1.) 0.)
	     (STORE (FINAL 2.) 0.)
	     (STORE (FINAL 3.) 0.)
	     (STORE (FINAL 4.) 0.)
	     (SETQ Z NIL)
	     (DISPLAY)
	     (RETURN 'SHUFFLED))) 

(DEFUN SHUFFLE1 (CARDS) (SHUFFLE2 52. NIL CARDS)) 

(DEFUN SHUFFLE2 (N NEW CARDS) 
       (IF (NULL CARDS)
	   NEW
	   ((LAMBDA (M) (SHUFFLE2 (SUB1 N)
				  (CONS (NTH M CARDS) NEW)
				  (DEL M CARDS)))
	    (RANDOM N)))) 

(DEFUN DEL (M LIS) 
       (IF (EQUAL M 0.)
	   (CDR LIS)
	   (CONS (CAR LIS) (DEL (SUB1 M) (CDR LIS))))) 

;;;This section contains heuristics.
;;;OBVIOUSLY generates obvious moves which can do no harm.  The
;;;simplest
;;;is if all remaining cards of a denomination can be played to final 
;;;piles.
;;;A unique legal move is obvious.
;;;
;;;A king may be played if all others are at the bottoms of
;;;final piles.
;;;In general, a card may be played if all others of that denomination
;;;and the cards they depend on are "rooted", i.e. left till last.
;;;
;;;LOSE tests whether the configuration is blocked.
(DEFUN OBVIOUSLY NIL 
       (PROG NIL 
	     (SETQ LEGALS
		   (APPEND (MAPCHOOSE (FUNCTION LEGAL1)
				      (APPEND POT1
					      (IF (NOT (NULL HAND))
						  '((F 1.)
						    (F 2.)
						    (F 3.)
						    (F 4.)))))
			   (IF (NOT (NULL HAND))
			       '((S 1.) (S 2.) (S 3.) (S 4.))
			       NIL)))
	     (SETQ OBVIOUSES (MAPCHOOSE 'OBVIOUS LEGALS))
	     (COND ((NULL (CDR LEGALS)) (SETQ OBVIOUSES LEGALS)))
	     (RETURN OBVIOUSES))) 

(SETQ POT1 '((1. 1.)
	     (1. 2.)
	     (1. 3.)
	     (1. 4.)
	     (2. 1.)
	     (2. 2.)
	     (2. 3.)
	     (2. 4.)
	     (3. 1.)
	     (3. 2.)
	     (3. 3.)
	     (3. 4.)
	     (4. 1.)
	     (4. 2.)
	     (4. 3.)
	     (4. 4.))) 

(DEFUN MAPCHOOSE (P U) 
       (COND ((NULL U) NIL)
	     ((APPLY P (LIST (CAR U)))
	      (CONS (CAR U) (MAPCHOOSE P (CDR U))))
	     (T (MAPCHOOSE P (CDR U))))) 

(DEFUN OBVIOUS (M1) 
       (IF (EQ (CAR M1) 'S)
	   (AND (NULL (STORAGE 1.))
		(NULL (STORAGE 2.))
		(NULL (STORAGE 3.))
		(NULL (STORAGE 4.)))
	   ((LAMBDA (K) (OR (AND (NOBURY K)
				 (OR (NULL HAND)
				     (NOT (MEMBER K (CDR HAND))))
				 (EQUAL (AVAILABLE K) (PLAYABLE K)))))
	    (IF (EQ (CAR M1) 'F)
		(CAR HAND)
		(CAR (STORAGE (CAR M1))))))) 

(DEFUN NOBURY (K) 
       (AND (NOBURY1 K (STORAGE 1.))
	    (NOBURY1 K (STORAGE 2.))
	    (NOBURY1 K (STORAGE 3.))
	    (NOBURY1 K (STORAGE 4.)))) 
(DEFUN NOBURY1 (K U) 
       (OR (NULL U)
	   (IF (EQUAL K (CAR U))
	       (NOBURY1 K (CDR U))
	       (NOT (MEMBER K (CDR U)))))) 

(DEFUN COUNT (N) 
       (PLUS (COUNT1 N (STORAGE 1.))
	     (COUNT1 N (STORAGE 2.))
	     (COUNT1 N (STORAGE 3.))
	     (COUNT1 N (STORAGE 4.))
	     (COUNT1 N HAND))) 

(DEFUN COUNT1 (N U) 
       (COND ((NULL U) 0.)
	     ((EQUAL (CAR U) N) (ADD1 (COUNT1 N (CDR U))))
	     (T (COUNT1 N (CDR U))))) 

(DEFUN AVAILABLE (N) 
       (PLUS (AVAIL1 N (STORAGE 1.))
	     (AVAIL1 N (STORAGE 2.))
	     (AVAIL1 N (STORAGE 3.))
	     (AVAIL1 N (STORAGE 4.))
	     (IF (AND (NOT (NULL HAND)) (EQUAL (CAR HAND) N)) 1. 0.)))
 

(DEFUN AVAIL1 (N U) 
       (IF (OR (NULL U) (NOT (EQUAL (CAR U) N)))
	   0.
	   (PLUS 1. (AVAIL1 N (CDR U))))) 

(DEFUN PLAYABLE (N) 
       (PLUS (IF (EQUAL N (NEXT 1.)) 1. 0.)
	     (IF (EQUAL N (NEXT 2.)) 1. 0.)
	     (IF (EQUAL N (NEXT 3.)) 1. 0.)
	     (IF (EQUAL N (NEXT 4.)) 1. 0.))) 

(DEFUN NEXT (M) (ADD1 (REMAINDER (SUB1 (PLUS M (FINAL M))) 13.)))